---
title: "COVID19 Dashboard"
output:
flexdashboard::flex_dashboard:
orientation: rows
vertical_layout: fill
social: [ "twitter", "facebook", "menu"]
source_code: embed
---
```{r setup, include=FALSE}
library(flexdashboard)
# library(knitr)
#integrar visualización
library(patchwork)
library(DT)
library(rpivotTable)
library(ggplot2)
library(plotly)
library(dplyr)
library(openintro)
library(highcharter)
library(ggvis)
library(tidyverse)
# library(tibbletime)
library(reactable)
library(htmltools)
library(fpp3)
library(feasts)
library(fable)
library(tsibble)
library(lubridate)
library(kableExtra)
library(formattable)
#importación y lectura
library(readxl)
library(tidyr)
library(vroom)
#Mapas
library(leaflet)
library(ggmap) # -> para obtener lon y lat de los municipios
library(raster)
library(spData)
library(tmap)
library(RJSONIO)
library(tmaptools)
library(Hmisc)
library(mxmaps) #se instala con un repo de gitgub con el
#siguiente comando
#if (!require("devtools")) {
# install.packages("devtools")
# }
# devtools::install_github("diegovalle/mxmaps")
library(sf)
library(scales) # needed for comma
library(rgeos)
library(maptools)
library(leaflet)
library(geojsonio)
library(jsonlite)
```
```{r}
#
# data <- read_csv("VehicleFailure.csv")
delitos <- read_csv("../Delitos/delitos2015-2021.csv",
locale(encoding = "latin1"),
col_names = TRUE,
col_types = NULL
)
#######Quedarse solo con las columnas y filas necesarias#######
delitos_a_comparar <- c("Feminicidio", "Abuso sexual",
"Acoso sexual", "Hostigamiento sexual",
"Otros delitos que atentan contra la libertad y la seguridad sexual",
"Violación simple", "Violación equiparada", "Trata de personas",
"Tráfico de menores", "Secuestro", "Violencia familiar")
delitos_tidy <- delitos %>%
filter( Tipo_de_delito %in% delitos_a_comparar |
Subtipo_de_delito == "Homicidio doloso" |
Subtipo_de_delito == "Lesiones dolosas" ) %>%
pivot_longer(
cols = Enero:Diciembre ,
names_to = "Meses",
values_to = "Cuenta"
) %>%
group_by(Ano, Meses, Tipo_de_delito, Subtipo_de_delito) %>%
summarise(Cuenta = sum(Cuenta), .groups = "drop")
delitos_tidy <- delitos_tidy %>%
mutate(
Meses = str_trunc(Meses, width = 3, ellipsis = ""),
Meses = case_when(
Meses == "Ene" ~ "Jan",
Meses == "Abr" ~ "Apr",
Meses == "Ago" ~ "Aug",
Meses == "Dic" ~ "Dec",
TRUE ~ Meses
)
) %>%
unite(col = "Fecha", c(Ano,Meses), sep = " ") %>%
mutate(Fecha = yearmonth(Fecha))
delitos_tidy_tsbl <- delitos_tidy %>%
as_tsibble(
index = Fecha,
key = c(Tipo_de_delito, Subtipo_de_delito)
)
#
# mycolors <- c("blue", "#FFC125", "darkgreen", "darkorange")
```
Delitos en época de COVID19
=====================================
Row
-------------------------------
### Tabla de incidencia
```{r}
#Tabla de incidencia (old)
#
# Incidencia_2019 <-delitos_tidy_tsbl %>%
# tsibble::group_by_key() %>%
# tsibble::index_by(Año = year(Fecha)) %>%
# dplyr::summarise(Cuenta = sum(Cuenta)) %>%
# dplyr::filter(Año %in% 2019) %>%
# dplyr::as_tibble(Incidencia_2019) %>%
# dplyr::transmute( Delito = Tipo_de_delito,
# Incidencia_2019 = Cuenta)
#
# Incidencia_2020 <- delitos_tidy_tsbl %>%
# group_by_key() %>%
#
# index_by(Año = year(Fecha)) %>%
#
# dplyr::summarise(Cuenta = sum(Cuenta)) %>%
# dplyr::filter(Año %in% 2020) %>%
# dplyr::as_tibble(Incidencia_2020) %>%
# dplyr::mutate(Delito = Tipo_de_delito,
# Incidencia_2020 = Cuenta) %>%
# dplyr::select(Delito, Incidencia_2020)
#
# Incidencia <- Incidencia_2020 %>%
# add_column(Incidencia_2019$Incidencia_2019) %>%
# dplyr::mutate(
# Porcentaje_de_cambio = round((
# (Incidencia_2020 - Incidencia_2019$Incidencia_2019)/Incidencia_2020), digits = 5),
# Incidencia_2019 = Incidencia_2019$Incidencia_2019) %>%
#
# dplyr::select(Delito, Incidencia_2019, Incidencia_2020, Porcentaje_de_cambio)%>%
# arrange(desc(Porcentaje_de_cambio))
#
# Tabla <- Incidencia %>%
# mutate(Porcentaje_de_cambio = percent(Porcentaje_de_cambio, 2)) %>%
# kbl(fortmat = "htlm", col.names = c("Delitos",
# "Incidencia en 2019",
# "Incidencia en 2020",
# "Porcentaje de cambio")) %>%
#
# kable_styling(bootstrap_options = "striped",
# full_width = F,
# position = "left",
# font_size = 14) %>%
#
# column_spec(4,color = ifelse( Incidencia$Porcentaje_de_cambio > 0, "red", "green"))
# Tabla
#Tabla de incidencia (new -> 13/marzo/2021)
incidencias <- delitos_tidy_tsbl %>%
group_by_key() %>%
index_by(Año = year(Fecha)) %>%
summarise(Cuenta = sum(Cuenta)) %>%
as_tibble(incidencias) %>%
mutate(cambio = (Cuenta / lag(Cuenta) - 1)*100) %>%
filter(Año != 2021)
Todos_delitos_gg <- incidencias %>%
ggplot(aes(x = Año, y = Cuenta, color = Tipo_de_delito)) +
geom_line(size = 1)+
facet_wrap(~ Tipo_de_delito, scales = "free_y") +
theme(legend.position = "none")
# perc_cambio_incidencias <- incidencias %>%
# ggplot(aes(x = Año, y = cambio, color = Subtipo_de_delito)) +
# geom_line() +
# geom_line(size = 1)+
# facet_wrap(~ Subtipo_de_delito, scales = "free_y") +
# theme(legend.position = "none")
# plotly::ggplotly(perc_cambio_incidencias)
incidencias <- incidencias %>%
pivot_wider(names_from = Año, values_from = Cuenta:cambio)
Tabla <- incidencias %>%
dplyr::select( Subtipo_de_delito, Cuenta_2019, Cuenta_2020, cambio_2020) %>%
arrange(-cambio_2020) %>%
transmute('Tipo de delito' = Subtipo_de_delito,
'Incidencia en 2019' = Cuenta_2019,
'Incidencia en 2020' = Cuenta_2020,
'Porcentaje de cambio' = round(cambio_2020, digits = 2))
customGreen0 = "#DeF7E9"
customGreen = "#71CA97"
customRed = "#ff7f7f"
cambio_format <-
formatter("span",
style = x ~ formattable::style(
font.weight = "bold",
color = ifelse(x < 0, customGreen, ifelse(x > 0, customRed, "black"))),
x ~ icontext(ifelse(x>0, "arrow-up", "arrow-down"), x)
)
formattable(Tabla,
align = c("l", rep("r", NCOL(Tabla) - 1)),
list('Tipo de delito' = formatter("span", style = ~ formattable::style(color = "grey", font.weight = "bold")),
'Porcentaje de cambio' = cambio_format
))
```
### Delitos sexuales y de género
```{r}
sexuales_y_genero = c("Abuso sexual",
"Acoso sexual",
"Feminicidio",
"Violación simple",
"Violación equiparada",
"Hostigamiento sexual",
"Otros delitos que atentan contra la libertad y la seguridad sexual")
# Grafica old
# p2 <- delitos_tidy_tsbl %>%
# filter (Tipo_de_delito %in% sexuales_y_genero) %>%
# ggplot() +
# geom_line(mapping = aes(x = Fecha, y = Cuenta, color = Tipo_de_delito))
#
# p2
delitos_sexuales_y_genero_gg <- delitos_tidy_tsbl %>%
filter (Tipo_de_delito %in% sexuales_y_genero) %>%
ggplot(aes(x = Fecha, y = Cuenta, color = Tipo_de_delito)) +
geom_line(size = 1)+
facet_wrap(~ Tipo_de_delito, scales = "free_y") +
theme(legend.position = "none")
delitos_sexuales_y_genero_gg
```
```{r}
#CargaDeDatos para generar gráficas de los delitos totales y en tasa de cambio
incidencias <- delitos_tidy_tsbl %>%
group_by_key() %>%
index_by(Anual = year(Fecha)) %>%
summarise(Cuenta = sum(Cuenta)) %>%
as_tibble(incidencias) %>%
mutate(cambio = (Cuenta / lag(Cuenta) - 1)*100) %>%
filter(Anual != 2021)
```
### Todos los delitos
```{r}
#gráfica old, delitos contra la libertad
# p3 <- delitos_tidy_tsbl %>%
# filter (Tipo_de_delito %in% c("Trata de personas", "Tráfico de menores", "Secuestro") ) %>%
# ggplot() +
# geom_line(mapping = aes(x = Fecha, y = Cuenta, color = Tipo_de_delito))
#
# p3
Todos_delitos_gg <- incidencias %>%
ggplot(aes(x = Anual, y = Cuenta, color = Tipo_de_delito)) +
geom_line(size = 1)+
facet_wrap(~ Tipo_de_delito, scales = "free_y") +
theme(legend.position = "none")
Todos_delitos_gg
```
Row
------------------------------------
### Cambio en la incidencia
```{r}
# gráfica old, delitos dolosos
# p4 <- delitos_tidy_tsbl %>%
# filter(Subtipo_de_delito %in% c("Lesiones dolosas", "Homicidio doloso")) %>%
# ggplot() +
# geom_line(mapping = aes(x = Fecha, y = Cuenta, color = Tipo_de_delito))
#
# p4
perc_cambio_incidencias <- incidencias %>%
ggplot(aes(x = Anual, y = cambio, color = Subtipo_de_delito)) +
geom_line() +
geom_line(size = 1)+
facet_wrap(~ Subtipo_de_delito, scales = "free_y") +
theme(legend.position = "none")
plotly::ggplotly(perc_cambio_incidencias)
```
Mapa nacional 1 y pruebas realizadas
========================================
Row
------------------------------------
### Mapa nacional de resultados positivos
```{r}
# car <- data %>%
# group_by(State) %>%
# summarize(total = n())
# car$State <- abbr2state(car$State)
#
# highchart() %>%
# hc_title(text = "Car Failures in US") %>%
# hc_subtitle(text = "Source: Vehiclefailure.csv") %>%
# hc_add_series_map(usgeojson, car,
# name = "State",
# value = "total",
# joinBy = c("woename", "State")) %>%
# hc_mapNavigation(enabled = T)
# lubridate::today()-1
# fecha <- "210415"
options(timeout = 700)
temp <- tempfile()
download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp)
Datosmex2502 <- vroom::vroom(unz(temp, unzip(temp, list = TRUE) %>% pull(Name)))
unlink(temp)
```
```{r}
Entidades <- read_xlsx("../Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES")
# Clasificación de datos -------------------------------------------------
#datos necesarios para la prueba
datosimportates <- dplyr::select(Datosmex2502,`FECHA_INGRESO`,`ENTIDAD_RES`,
`TOMA_MUESTRA_LAB`,`RESULTADO_LAB`, `TOMA_MUESTRA_ANTIGENO`,
`RESULTADO_ANTIGENO`, `CLASIFICACION_FINAL`)%>%
left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD"))
#datos confirmados sin realización de pruebas
confirmados <- datosimportates %>%
filter(`CLASIFICACION_FINAL`%in% c(1,2,3)) %>%
dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `ABREVIATURA`) %>%
mutate(
year = lubridate::year(FECHA_INGRESO),
month = lubridate::month(FECHA_INGRESO),
day = lubridate::day(FECHA_INGRESO)
) %>%
drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`)
# Agrupación de datos ----------------------------------------------------
#Numero de positivos por estado
positivosestado <- confirmados %>%
group_by(`ENTIDAD_RES`) %>%
summarise(
count=n(),
)
#Selección de nombre estados, por orden de codigo
nombreEstado <- Entidades %>%
dplyr::select(`ENTIDAD_FEDERATIVA`) %>%
slice( 1:32)
mapaPositivos <- positivosestado %>%
add_column(nombreEstado)
# Mapa -------------------------------------------------------------------
# data(mapaPositivos)
# mapaPositivos$rand <- mapaPositivos$count
# mapaPositivos$region <- mapaPositivos$ENTIDAD_RES
# mxstate_choropleth(mapaPositivos,
# title = "Casos confirmados de COVID por estado.",
# legend = "Número de casos.",
# )
# Convert the topoJSON to spatial object
tmpdir <- tempdir()
# have to use RJSONIO or else the topojson isn't valid
write(RJSONIO::toJSON(mxstate.topoJSON), file.path(tmpdir, "sta.topojson"))
mxstate <- topojson_read(file.path(tmpdir, "sta.topojson"))
#ordenamos los datos del topoJSON en orden numérico
mxstate <- mxstate[order(mxstate$id),]
mxstate <- as_Spatial(mxstate)
mxstate$rand <- mapaPositivos$count
bins <- c(5000,20000 , 30000, 35000, 50000, 60000, 115000,300000, Inf)
pal <- colorBin("YlOrRd", domain = mxstate$rand, bins=bins)
etiqueta <- paste(
"Estado: ", mapaPositivos$ENTIDAD_FEDERATIVA, "
",
"Número de casos: ", mapaPositivos$count
) %>%
lapply(htmltools::HTML)
leaflet(mxstate) %>%
addPolygons(
fillColor = ~pal(mxstate$rand),
fillOpacity = 1,
stroke = TRUE,
color = "White",
weight = 1.5,
dashArray = "3",
highlight = highlightOptions(
weight = 5,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE),
label = etiqueta,
)%>%
addLegend(pal = pal, values = ~mapaPositivos$rand, opacity = 0.7, title = "Casos
positivos
contagios",
position = "bottomright")%>%
addTiles() %>%
addMarkers(50, 50) %>%
addControl("Positivos totales COVID19 México", position = "bottomleft") %>%
addProviderTiles("CartoDB.Positron")
```
Row
------------------------------------
### Pruebas realizadas por estado
```{r}
# # Importación de datos ----------------------------------------------------
#
#
# # Datosmex2502 <- read_csv("210225COVID19MEXICO.csv")
# # Descarga de datos desde la página web
# fecha <- "210412"
# options(timeout = 600)
# temp <- tempfile()
# download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp)
#
#
# Datosmex2502 <- vroom::vroom(unz(temp, paste0(fecha,"COVID19MEXICO.csv")))
# unlink(temp)
#
#
# Entidades <- read_xlsx("Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES")
# # Clásificación ----------------------------------------------------------
#
# #datos necesarios para la prueba
# datosimportates <- dplyr::select(Datosmex2502,`FECHA_INGRESO`,`ENTIDAD_RES`,
# `TOMA_MUESTRA_LAB`,`RESULTADO_LAB`, `TOMA_MUESTRA_ANTIGENO`,
# `RESULTADO_ANTIGENO`, `CLASIFICACION_FINAL`)%>%
# left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD"))
#datos de las pruebas realizadas ese día en todo el país
pruebasfiltro <- datosimportates %>%
dplyr::filter(`TOMA_MUESTRA_LAB`== 1 | `TOMA_MUESTRA_ANTIGENO`==1 ) %>%
dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`,`ENTIDAD_FEDERATIVA`,`ABREVIATURA`) %>%
mutate(
year = lubridate::year(FECHA_INGRESO),
month = lubridate::month(FECHA_INGRESO),
day = lubridate::day(FECHA_INGRESO)
) %>%
drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`)
# Agrupación de datos ----------------------------------------------------
#Numero de pruebas por estado totales hasta la fecha de datos
pruebasXEstado <- pruebasfiltro %>%
group_by(`ENTIDAD_FEDERATIVA`) %>%
mutate(`Numero de pruebas`=n()) %>%
distinct(`ENTIDAD_FEDERATIVA`, .keep_all = TRUE) %>%
arrange(`ENTIDAD_FEDERATIVA`) %>%
drop_na(`ENTIDAD_FEDERATIVA`)
pruebasXEstado <- pruebasXEstado %>%
dplyr::select(
`ENTIDAD_FEDERATIVA`,
`Numero de pruebas`
)
pruebasfiltro$FECHA_INGRESO <- format(pruebasfiltro$FECHA_INGRESO, "%Y-%m")
#Numero de pruebas por estado según el día
pruebasxEstadoxDia <- pruebasfiltro %>%
group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>%
mutate(count=n()) %>%
distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>%
arrange(`ENTIDAD_RES`) %>%
drop_na(`ENTIDAD_FEDERATIVA`)
# Gráfica ----------------------------------------------------------------
ggplot(data = pruebasfiltro) +
geom_bar(mapping = aes(y = FECHA_INGRESO, fill = ABREVIATURA), position = "dodge")
```
### Pruebas realizadas por estado
```{r}
# Tabla ------------------------------------------------------------------
#Tabla que muestra el número de pruebas que se hacen por día en los estados
formattable(pruebasXEstado, #llamo datos
align =c("l","c"), #Para alinear los datos de la tabla cada "" es una columna
list(`ENTIDAD_FEDERATIVA` = formatter( #datos específicos
"span", style = ~ style(color = "grey",font.weight = "bold")),
`Numero de pruebas` = color_bar("Red") # me crea una barra roja con proporción a los datos
)
)
```
Mapa porcentaje de positividad
========================================
Row
------------------------------------
### Porcentaje total
```{r}
# Importación de datos ----------------------------------------------------
#Datosmex2502 <- read_csv("210225COVID19MEXICO.csv")
# Descarga de datos desde la página web
# fecha <- "210414"
# options(timeout = 700)
# temp <- tempfile()
# download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp)
#
#
# Datosmex2502 <- vroom::vroom(unz(temp, unzip(temp, list = TRUE) %>% pull(Name)))
# unlink(temp)
#
#
# Entidades <- read_xlsx("Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES")
#
# # Clasificación de datos -------------------------------------------------
#
# #datos necesarios para la prueba
# datosimportates <- dplyr::select(Datosmex2502,`FECHA_INGRESO`,`ENTIDAD_RES`,
# `TOMA_MUESTRA_LAB`,`RESULTADO_LAB`, `TOMA_MUESTRA_ANTIGENO`,
# `RESULTADO_ANTIGENO`, `CLASIFICACION_FINAL`)%>%
# left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD"))
#
#
#
# #datos confirmados sin realización de pruebas
# confirmados <- datosimportates %>%
# filter(`CLASIFICACION_FINAL`%in% c(1,2,3)) %>%
# dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`, `ENTIDAD_FEDERATIVA`, `ABREVIATURA`) %>%
# mutate(
# year = lubridate::year(FECHA_INGRESO),
# month = lubridate::month(FECHA_INGRESO),
# day = lubridate::day(FECHA_INGRESO)
# ) %>%
# drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`)
#datos de las pruebas realizadas ese día en todo el país
pruebasfiltro <- datosimportates %>%
dplyr::filter(`TOMA_MUESTRA_LAB`== 1 | `TOMA_MUESTRA_ANTIGENO`==1 ) %>%
dplyr::select(`FECHA_INGRESO`, `ENTIDAD_RES`,`ENTIDAD_FEDERATIVA`,`ABREVIATURA`) %>%
mutate(
year = lubridate::year(FECHA_INGRESO),
month = lubridate::month(FECHA_INGRESO),
day = lubridate::day(FECHA_INGRESO)
) %>%
drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`)
#Separación de datos por fechas para mapas
pruebas2020 <- dplyr::filter(pruebasfiltro, year==2020)
pruebEstado2020 <- pruebas2020 %>%
group_by(`ENTIDAD_RES`) %>%
summarise(
count=n()
)
pruebas2021 <- dplyr::filter(pruebasfiltro, year==2021)
pruebEstado2021 <- pruebas2021 %>%
group_by(`ENTIDAD_RES`) %>%
summarise(
count=n()
)
#confirmados por año para mapas
confirm2020 <- confirmados %>%
dplyr::filter( year==2020) %>%
drop_na(`ENTIDAD_FEDERATIVA`)
confirmEstado2020 <- confirm2020 %>%
group_by(`ENTIDAD_RES`) %>%
summarise(
count=n()
)
confirm2021 <- confirmados %>%
dplyr::filter( year==2021) %>%
drop_na(`ENTIDAD_FEDERATIVA`)
confirmEstado2021 <- confirm2021 %>%
group_by(`ENTIDAD_RES`) %>%
summarise(
count=n()
)
#Numero de pruebas por estado totales hasta la fecha de datos
pruebasXEstado <- pruebasfiltro %>%
group_by(`ENTIDAD_RES`) %>%
mutate(PRUEBAS=n()) %>%
distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>%
arrange(`ENTIDAD_RES`) %>%
drop_na()
# #Numero de pruebas por estado según el día
# pruebasxEstadoxDia <- pruebasfiltro %>%
# group_by(`ENTIDAD_RES`,`FECHA_INGRESO`) %>%
# mutate(count=n()) %>%
# distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>%
# arrange(`ENTIDAD_RES`) %>%
# drop_na()
#
#
# prubeasXEstadotsbl <- pruebasxEstadoxDia %>%
# as_tsibble( key = `ENTIDAD_RES`,
# index = `FECHA_INGRESO`
# )
# group_split(pruebasxEstadoxDia)
# group_keys(pruebasxEstadoxDia)
#Positivos por estado totales hasta la fecha de datos
positivoxEstado <- confirmados %>%
group_by(`ENTIDAD_RES`) %>%
mutate(CONFIRMADOS=n()) %>%
distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>%
arrange(`ENTIDAD_RES`) %>%
dplyr::select(ENTIDAD_RES, ENTIDAD_FEDERATIVA, CONFIRMADOS )
# #Positivos por estado según el día
# positivoxEstadoxDia <- confirmados %>%
# group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>%
# mutate(count=n()) %>%
# distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>%
# arrange(`ENTIDAD_RES`) %>%
# drop_na()
#
# positivoXDiatsbl <- positivoxEstadoxDia %>%
# as_tsibble( key = ENTIDAD_RES,
# index = FECHA_INGRESO
#
# )
#Selección de nombre estados, por orden de codigo
nombreEstado <- Entidades %>%
dplyr::select(`ENTIDAD_FEDERATIVA`) %>%
slice( 1:32)
# Agrupación de datos totales -----------------------------------------------------
# #suma total de las pruebas realizadas
totalpruebas <- pruebasXEstado$PRUEBAS %>%
sum(na.rm = TRUE)
#suma total de las pruebas que salieron positivas
totalpositivas <- positivoxEstado$CONFIRMADOS %>%
sum(na.rm = TRUE)
#Porcentaje por estado de las pruebas positivas a el total de pruebas realizadas en los estados
positividadPais <- (totalpositivas/totalpruebas)*100
#positividadPais
positividad <- ((positivoxEstado$CONFIRMADOS/pruebasXEstado$PRUEBAS)*100)
#positividad
#porcentaje total de las pruebas positivas de acuerdo a que estado.
porcenestado <- (positivoxEstado$CONFIRMADOS/totalpositivas)*100
porcenestado <- as.numeric(porcenestado)
#porcenestado
#Porcentaje total de pruebas positvas
porcen <- sum(positividad, na.rm = TRUE)
#verificación de suma de porcentaje de pruebas positivas (porcenestado)
sumporcentaje <- sum(porcenestado, na.rm = TRUE)
# creamos tibble con datos de codigo de entidad y casos positivos
nueva <- positivoxEstado %>%
#agregamos porcentajes de acuerdo al total de pruebas positivas
add_column(porcenestado)%>%
#agregamos porcentajes del total de pruebas
add_column(positividad) %>%
add_column(pruebasXEstado$PRUEBAS)
# #Agregamos el nombre de los estados por orden de codigo
# add_column(nombreEstado)
# Agrupación de datos 2020 ------------------------------------------------
# #suma total de las pruebas realizadas
# totalpruebas2020 <- pruebEstado2020$count %>%
# sum(na.rm = TRUE)
#suma total de las pruebas que salieron positivas
totalpositivas2020 <- confirmEstado2020$count %>%
sum(na.rm = TRUE)
#Porcentaje por estado de las pruebas positivas a el total de pruebas realizadas en los estados
positividad2020 <- (confirmEstado2020$count/pruebEstado2020$count)*100
#positividad2020
#porcentaje total de las pruebas positivas de acuerdo a que estado.
porcenestado2020 <- (confirmEstado2020$count/totalpositivas2020)*100
porcenestado2020 <- as.numeric(porcenestado)
#porcenestado2020
#Porcentaje total de pruebas positvas
porcen2020 <- sum(positividad2020, na.rm = TRUE)
#verificación de suma de porcentaje de pruebas positivas (porcenestado)
sumporcentaje2020 <- sum(porcenestado2020, na.rm = TRUE)
# creamos tibble con datos de codigo de entidad y casos positivos
nueva2020 <- confirmEstado2020 %>%
#agregamos porcentajes de acuerdo al total de pruebas positivas
add_column(porcenestado2020)%>%
#agregamos porcentajes del total de pruebas
add_column(positividad2020) %>%
#Agregamos el nombre de los estados por orden de codigo
add_column(nombreEstado)
# Agrupación de datos 2021 ------------------------------------------------
# #suma total de las pruebas realizadas
# totalpruebas2021 <- pruebEstado2021$count %>%
# sum(na.rm = TRUE)
#suma total de las pruebas que salieron positivas
totalpositivas2021 <- confirmEstado2021$count %>%
sum(na.rm = TRUE)
#Porcentaje por estado de las pruebas positivas a el total de pruebas realizadas en los estados
positividad2021 <- (confirmEstado2021$count/pruebEstado2021$count)*100
#positividad2021
#porcentaje total de las pruebas positivas de acuerdo a que estado.
porcenestado2021 <- (confirmEstado2021$count/totalpositivas2021)*100
porcenestado2021 <- as.numeric(porcenestado2021)
#porcenestado2021
#Porcentaje total de pruebas positvas
porcen2021 <- sum(positividad2021, na.rm = TRUE)
#verificación de suma de porcentaje de pruebas positivas (porcenestado)
sumporcentaje2021 <- sum(porcenestado2021, na.rm = TRUE)
# creamos tibble con datos de codigo de entidad y casos positivos
nueva2021 <- confirmEstado2021 %>%
#agregamos porcentajes de acuerdo al total de pruebas positivas
add_column(porcenestado2021)%>%
#agregamos porcentajes del total de pruebas
add_column(positividad2021) %>%
#Agregamos el nombre de los estados por orden de codigo
add_column(nombreEstado)
# Mapa de positividad total --------------------------------------------------------------------
# de acuerdo al número de pruebas realizadas se calcula el porcentaje de las
#pruebas que fueron seleccionadas como positivas. (por estado)
#data(nueva)
nueva$value <- nueva$positividad
nueva$region <- nueva$ENTIDAD_RES
# mxstate_choropleth(nueva,
# num_colors = 1,
# title = "Porcentaje de casos positivos",
# legend = "%",
# )
#Mapa interactivo
bins = c(15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51, 54, 57, 60, 63, 66, 69, 72)
pal <- colorBin("viridis", domain = nueva$value, bins=bins)
mxstate_leaflet(nueva,
pal,
~ pal(value),
~ sprintf("Estado: %s
Porcentaje de positividad : %s",
ENTIDAD_FEDERATIVA , comma(value) )) %>%
addLegend(position = "bottomright",
pal = pal,
values = nueva$value,
title = "Percentaje
Positividad",
labFormat = labelFormat(suffix = "%",
)) %>%
addTiles() %>%
addMarkers(50, 50) %>%
addControl("Mapa positividad de las pruebas totales", position = "bottomleft") %>%
addProviderTiles("CartoDB.Positron")
```
Row
------------------------------------
### Porcentaje 2020
```{r}
# Mapa 2020 ---------------------------------------------------------------
# de acuerdo al número de pruebas realizadas se calcula el porcentaje de las
#pruebas que fueron seleccionadas como positivas. (por estado del año 2020)
data(nueva2020)
nueva2020$value <- nueva2020$positividad2020
nueva2020$region <- nueva2020$ENTIDAD_RES
# mxstate_choropleth(nueva,
# num_colors = 1,
# title = "Porcentaje de casos positivos",
# legend = "%",
# )
#Mapa interactivo
bins=c(15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51, 54, 57, 60, 63, 66, 69, 72)
pal <- colorBin("viridis", domain = nueva2020$value, bins=bins)
mxstate_leaflet(nueva2020,
pal,
~ pal(value),
~ sprintf("Estado: %s
Porcentaje de positividad : %s",
ENTIDAD_FEDERATIVA , comma(value) )) %>%
addLegend(position = "bottomright",
pal = pal,
values = nueva2020$value,
title = "Percentaje
Positividad",
labFormat = labelFormat(suffix = "%",
)) %>%
addTiles() %>%
addMarkers(50, 50) %>%
addControl("Mapa positividad de las pruebas en 2020", position = "bottomleft") %>%
addProviderTiles("CartoDB.Positron")
```
### Porcentaje 2021
```{r}
# Mapa 2021 ---------------------------------------------------------------
# de acuerdo al número de pruebas realizadas se calcula el porcentaje de las
#pruebas que fueron seleccionadas como positivas. (por estado del año 2021)
data(nueva2021)
nueva2021$value <- nueva2021$positividad2021
nueva2021$region <- nueva2021$ENTIDAD_RES
# mxstate_choropleth(nueva2021,
# num_colors = 1,
# title = "Porcentaje de casos positivos",
# legend = "%",
# )
#Mapa interactivo
bins = c(15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51, 54, 57, 60, 63, 66, 69, 72)
pal <- colorBin("viridis", domain = nueva2021$value, bins=bins)
mxstate_leaflet(nueva2021,
pal,
~ pal(value),
~ sprintf("Estado: %s
Porcentaje de positividad : %s",
ENTIDAD_FEDERATIVA , comma(value) )) %>%
addLegend(position = "bottomright",
pal = pal,
values = nueva2021$value,
title = "Percentaje
Positividad",
labFormat = labelFormat(suffix = "%",
)) %>%
addTiles() %>%
addMarkers(50, 50) %>%
addControl("Mapa positividad de pruebas en 2021", position = "bottomleft") %>%
addProviderTiles("CartoDB.Positron")
```
```{r}
# Carga de datos ----------------------------------------------------------
#Se importan los datos como un tibble
Vacunastotales <- readr::read_csv("https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/vaccinations/vaccinations.csv")
# Wrangle data ------------------------------------------------------------
#Se quiere trabajar con series de tiempo, entonces convertimos
# a tsibble un objeto que tiene orientación a este tiempo de
#procesamiento
Vacunastotales_tsibble <- Vacunastotales %>%
dplyr::mutate(Daily = as.Date(date)) %>%
dplyr::select(-date) %>%
tsibble::as_tsibble(key = location,
index = Daily)
#se hace una variable con los nombres de los paises de
#LATAM para asi poder llamar la variable a buscar en
#la base de datos si se requiere, esto esta pensado
#en que la instrucción podría hacerse varias veces
#entonces en teoría debería simplificar el código
latam <- c("Mexico", "Argentina",
"Colombia", "Chile",
"Brazil", "Bolivia",
"Costa Rica", "Ecuador",
"Guatemala", "Panama",
"Paraguay", "Peru",
"Puerto Rico", "Dominican Republic")
#Se encontro que era particularmente complicado mostrar
#todos los datos en una sola gráfica, por lo tanto,
#graficar por secciones y pegar con patchwork es una
#opción viable, por lo que la variable length(latam) = 14
#entonces dividimos en 2 grupos para tener símetria.
latam1 <- latam[1:7]
latam2 <- latam[8:14]
#latam == latam1 + latam2
#hacemos otro dafa frame que solo sea para los de
#LATAM y asi trabajamos con un tsibble más pequeña
Vacunas_latam_tsibble <- Vacunastotales_tsibble %>%
dplyr::select( Daily, location, total_vaccinations,
total_vaccinations_per_hundred,
daily_vaccinations_per_million) %>%
filter(location %in% latam)
```
Ranking Nacional
=========================================
### Calificación por estado para manejo de la pandemia
```{r echo = FALSE, results= 'hide'}
# # Importación de datos ----------------------------------------------------
#
# # Descarga de datos desde la página web
# # fecha <- "210415"
# options(timeout = 700)
# temp <- tempfile()
# download.file("http://datosabiertos.salud.gob.mx/gobmx/salud/datos_abiertos/datos_abiertos_covid19.zip", temp)
#
#
# Datosmex2502 <- vroom::vroom(unz(temp, unzip(temp, list = TRUE) %>% pull(Name)))
# unlink(temp)
#
# Entidades <- read_xlsx("Datos nacionales abiertos/201128 Catalogos.xlsx",sheet="Catálogo de ENTIDADES")
# Selección de datos ------------------------------------------------------
#datos necesarios para la prueba
FiltImpoData <- dplyr::select(Datosmex2502,
`FECHA_INGRESO`,
`ENTIDAD_RES`,
`TOMA_MUESTRA_LAB`,
`RESULTADO_LAB`,
`TOMA_MUESTRA_ANTIGENO`,
`RESULTADO_ANTIGENO`,
`CLASIFICACION_FINAL`,
`FECHA_DEF`,
)%>%
left_join(Entidades, by=c("ENTIDAD_RES"="CLAVE_ENTIDAD"))
#Población en cada estado del país, con datos a 2020
poblacionEstado <- dplyr::select(df_mxstate_2020,
`region`,
`state_name`,
`pop`,
)
# Filtro de datos en tibbles ---------------------------------------------------------
#datos confirmados
confirm <- FiltImpoData %>%
filter(`CLASIFICACION_FINAL`%in% c(1,2,3)) %>%
drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) %>% #borramos los datos NA que generan más filas(son pocos)
arrange(`FECHA_INGRESO`)
#Casos terminados en muerte
muertesConfirm <- FiltImpoData %>%
filter(!is.na(`FECHA_DEF`)) %>%
drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) #quitamos datos NA (no interfiere)
#datos de las pruebas realizadas ese día en todo el país
filtroPrueba <- FiltImpoData %>%
dplyr::filter(`TOMA_MUESTRA_LAB`== 1 | `TOMA_MUESTRA_ANTIGENO`==1 ) %>% #seleccuón de datos con pruebas
drop_na(`ENTIDAD_FEDERATIVA`, `FECHA_INGRESO`) #borrar datos NA (no afecta)
# Medias moviles de los estados casos positivos -----------------------------------------------------
positivosXEstaXDia <- confirm %>%
dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>%
mutate(POSITIVOS=n()) %>%
distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>%
arrange(`FECHA_INGRESO`) %>%
dplyr::select(`FECHA_INGRESO`,
`ENTIDAD_RES`,
`ENTIDAD_FEDERATIVA`,
`FECHA_DEF`,
`POSITIVOS`,
)
#promedio de los últimos catorce días
positivosXEstaXDia %>%
group_by(ENTIDAD_FEDERATIVA) %>%
slice_tail(n = 14)
# %>%
# summarise(Promedio = mean(POSITIVOS))
#media movil de 14 días
positivos_tsbl <- positivosXEstaXDia %>%
ungroup() %>%
as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>%
mutate(
`14-MA` = slider::slide_dbl(POSITIVOS, mean,
.before = 14, .complete = TRUE)
)
# #gráfica de los positivos con la medi movil
# positivos_tsbl %>%
# feasts::autoplot(POSITIVOS) +
# geom_line(aes(y = `14-MA`), color = "black") +
# facet_wrap(~ ENTIDAD_FEDERATIVA, scales = "free_y") +
# theme(legend.position = "none")
# Medias moviles de los estados casos negativos ---------------------------
muertesXEstaXDia <- muertesConfirm %>%
dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>%
mutate(MUERTES=n()) %>%
distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>%
arrange(`FECHA_INGRESO`) %>%
dplyr::select(`FECHA_INGRESO`,
`ENTIDAD_RES`,
`ENTIDAD_FEDERATIVA`,
`FECHA_DEF`,
`MUERTES`
)
#promedio de los últimos catorce días
muertesXEstaXDia %>%
group_by(ENTIDAD_FEDERATIVA) %>%
slice_tail(n = 14)
# %>%
# summarise(Promedio = mean(MUERTES))
#media movil de 14 días
muertes_tsbl <- muertesXEstaXDia %>%
ungroup() %>%
as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>%
mutate(
`14-MA` = slider::slide_dbl(MUERTES, mean,
.before = 14, .complete = TRUE)
)
# #gráfica de los positivos con la medi movil
# muertes_tsbl %>%
# feasts::autoplot(MUERTES) +
# geom_line(aes(y = `14-MA`), color = "black") +
# facet_wrap(~ ENTIDAD_FEDERATIVA, scales = "free_y") +
# theme(legend.position = "none")
# medias movil positivos por millon de habitantes -------------------------
positivosXEstaXDiaXmillon <- positivosXEstaXDia %>%
left_join(poblacionEstado, by=c("ENTIDAD_RES"="region"))
positivosXEstaXDiaXmillon$POSITIVOS <- (positivosXEstaXDiaXmillon$POSITIVOS*1000000)/positivosXEstaXDiaXmillon$pop
#media movil de 14 días
positivosmillon_tsbl <- positivosXEstaXDiaXmillon %>%
ungroup() %>%
as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>%
mutate(
`14-MA` = slider::slide_dbl(POSITIVOS, mean,
.before = 14, .complete = TRUE)
)
# media movil muertes por millon de habitantes ----------------------------
muertesXEstaXDiaXmillon <- muertesXEstaXDia %>%
left_join(poblacionEstado, by=c("ENTIDAD_RES"="region"))
muertesXEstaXDiaXmillon$MUERTES <- (muertesXEstaXDiaXmillon$MUERTES*1000000)/muertesXEstaXDiaXmillon$pop
#media movil de 14 días
muertesmillon_tsbl <- muertesXEstaXDiaXmillon %>%
ungroup() %>%
as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>%
mutate(
`14-MA` = slider::slide_dbl(MUERTES, mean,
.before = 14, .complete = TRUE)
)
# media movil de la positividad -------------------------------------------
PruePosiXEstaXDia <- filtroPrueba %>%
dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>%
mutate(PRUEBAS=n()) %>%
distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>%
arrange(`FECHA_INGRESO`) %>%
dplyr::select(`FECHA_INGRESO`,
`ENTIDAD_RES`,
`ENTIDAD_FEDERATIVA`,
`FECHA_DEF`,
`PRUEBAS`) %>%
left_join(positivosXEstaXDia, positivosXEstaXDia, by= c("ENTIDAD_RES", "FECHA_INGRESO", "ENTIDAD_FEDERATIVA"))
PruePosiXEstaXDia$POSITIVIDAD <- (PruePosiXEstaXDia$POSITIVOS/PruePosiXEstaXDia$PRUEBAS)*100
#media movil de 14 días
positivdad_tsbl <- PruePosiXEstaXDia %>%
ungroup() %>%
as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>%
mutate(
`14-MA` = slider::slide_dbl(POSITIVIDAD, mean,
.before = 14, .complete = TRUE)
)
# Media movil de pruebas por cada 1000 habitantes --------------------------
pruebasXEstaXDia<- filtroPrueba %>%
dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>%
mutate(PRUEBAS=n()) %>%
distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>%
arrange(`FECHA_INGRESO`) %>%
dplyr::select(`FECHA_INGRESO`,
`ENTIDAD_RES`,
`ENTIDAD_FEDERATIVA`,
`FECHA_DEF`,
`PRUEBAS`) %>%
left_join(poblacionEstado, by=c("ENTIDAD_RES"="region"))
pruebasXEstaXDia$XMILHAB <- ((1000*pruebasXEstaXDia$PRUEBAS)/pruebasXEstaXDia$pop)
#media movil de 14 días
pruebas_tsbl <- pruebasXEstaXDia %>%
ungroup() %>%
as_tsibble(index = FECHA_INGRESO, key = ENTIDAD_FEDERATIVA) %>%
mutate(
`14-MA` = slider::slide_dbl(XMILHAB, mean,
.before = 14, .complete = TRUE)
)
# Indicadores por día en cada estado -------------------------------------
# #Por día hacemos un conteo de los casos que se confirmaron en cada estado
# positivosXEstaXDia <- confirm %>%
# dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>%
# mutate(POSITIVOS=n()) %>%
# distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>%
# arrange(`FECHA_INGRESO`) %>%
# select(`FECHA_INGRESO`,
# `ENTIDAD_RES`,
# `ENTIDAD_FEDERATIVA`,
# `FECHA_DEF`,
# `POSITIVOS`,
# )# %>%
# # add_column(SUMS=NA)
#
# #Para generar las tablas de cada uno de los estados con su conteo
# for(i in unique(positivosXEstaXDia$`ENTIDAD_RES`)) {
# nam <- paste0("positivoE.", i )
# assign(nam, positivosXEstaXDia[positivosXEstaXDia$`ENTIDAD_RES`==i,])
#
# }
#
# muertesXEstaXDia <- muertesConfirm %>%
# dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>%
# mutate(MUERTES=n()) %>%
# distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>%
# arrange(`FECHA_INGRESO`) %>%
# select(`FECHA_INGRESO`,
# `ENTIDAD_RES`,
# `ENTIDAD_FEDERATIVA`,
# `FECHA_DEF`,
# `MUERTES`
# )
# for(i in unique(muertesXEstaXDia$`ENTIDAD_RES`)) {
# nam <- paste("muertesE", i, sep = ".")
# assign(nam, muertesXEstaXDia[muertesXEstaXDia$ENTIDAD_RES==i,])
# }
# pruebasXEstaXDia <- filtroPrueba %>%
# dplyr::group_by(`ENTIDAD_RES`, `FECHA_INGRESO`) %>%
# mutate(PRUEBAS=n()) %>%
# distinct(`FECHA_INGRESO`, .keep_all = TRUE) %>%
# arrange(`FECHA_INGRESO`) %>%
# select(`FECHA_INGRESO`,
# `ENTIDAD_RES`,
# `ENTIDAD_FEDERATIVA`,
# `FECHA_DEF`,
# `PRUEBAS`)
# for(i in unique(pruebasXEstaXDia$`ENTIDAD_RES`)) {
# nam <- paste("pruebasE", i, sep = ".")
# assign(nam, pruebasXEstaXDia[pruebasXEstaXDia$ENTIDAD_RES==i,])
# # add_column(rollsumr("pruebasE".i$PRUEBAS, k = 14, fill = NA))
# # pruebasE.i$promedio <- rollmean(`PRUEBAS`, k = 14, fill = NA, aling="rigth")
# }
# for (i in tibble("pruebasE", i,sep="·")){
# tibble("pruebasE", i,sep="·")$sums <-rollsumr(PRUEBAS, k = 14, fill = NA) %>%
# tibble("pruebasE", i,sep="·")$promedio <- rollmean(PRUEBAS, k = 14, fill = NA, aling="rigth")
# }
# Promedio al día indicadores por estados -------------------------------------------------------------
positivosXEstados <- confirm %>%
group_by(`ENTIDAD_RES`) %>%
mutate(Positivos=n()) %>%
distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>%
arrange(`ENTIDAD_RES`) %>%
dplyr::select(
`ENTIDAD_RES`,
`ENTIDAD_FEDERATIVA`,
`ABREVIATURA`,
`Positivos`)
# #gestapo positivos al día en cada estado
# positivosXEstaXDia <- positivosXEstaXDia %>%
# ungroup() %>%
# group_by(`ENTIDAD_RES`) %>%
# mutate(
# PROM=mean(POSITIVOS)
#
# )
muertesXEstado <- muertesConfirm %>%
group_by(`ENTIDAD_RES`) %>%
mutate(Muertes=n()) %>%
distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>%
arrange(`ENTIDAD_RES`) %>%
dplyr::select(`ENTIDAD_RES`,
`ENTIDAD_FEDERATIVA`,
`ABREVIATURA`,
`Muertes`)
# #promedios de muertes al día en cada estado
# muertesXEstaXDia <- muertesXEstaXDia %>%
# ungroup() %>%
# group_by(`ENTIDAD_RES`) %>%
# mutate(
# PROM=mean(MUERTES)
#
# )
pruebasXEstado <- filtroPrueba %>%
group_by(`ENTIDAD_RES`) %>%
mutate(Pruebas=n()) %>%
distinct(`ENTIDAD_RES`, .keep_all = TRUE) %>%
arrange(`ENTIDAD_RES`) %>%
dplyr::select(`ENTIDAD_RES`, # selección de datos necesarios
`ENTIDAD_FEDERATIVA`,
`ABREVIATURA`,
`Pruebas`)
# Por millon de habitantes ------------------------------------------------
posiXEstaXMillon <- ((1000000*positivosXEstados$Positivos)/poblacionEstado$pop)
muerteXEstaXMillon <- ((1000000*muertesXEstado$Muertes)/poblacionEstado$pop)
# Positividad ------------------------------------------------------------
PositividadIndica <- (positivosXEstados$Positivos/pruebasXEstado$Pruebas)*100
# Pruebas por mil habitantes ---------------------------------------------
pruebasXEstaXMilhab <- ((1000*pruebasXEstado$Pruebas)/poblacionEstado$pop)
# Tabla con datos finales xEstado -------------------------------------------------
indicadoresFinal <- positivosXEstados %>%
tibble::add_column(muertesXEstado$Muertes) %>%
tibble::add_column(pruebasXEstado$Pruebas) %>%
tibble::add_column(posiXEstaXMillon) %>%
tibble::add_column(muerteXEstaXMillon) %>%
tibble::add_column(PositividadIndica) %>%
tibble::add_column(pruebasXEstaXMilhab)
indicadoresFinal <- indicadoresFinal %>%
ungroup() %>%
group_by(`ENTIDAD_FEDERATIVA`) %>%
mutate(
SUM= sum(`Positivos`,
`muertesXEstado$Muertes`,
posiXEstaXMillon,
muerteXEstaXMillon,
PositividadIndica,
pruebasXEstaXMilhab,
na.rm = TRUE),
PROM = (SUM/6)
)
PromIndica <- indicadoresFinal %>%
dplyr::select(`ENTIDAD_RES`,
`ENTIDAD_FEDERATIVA`,
`PROM`)
# summary(PromIndica)
# Normalización ----------------------------------------------------------
# library(caret)
#
#
# preproc2 <- preProcess(PromIndica[,c(1:3)], method=c("range"))
#
# norm2 <- predict(preproc2, PromIndica[,c(1:3)])
#
# summary(norm2)
normalize <- function(x) {
return (((x - min(x))*(100) / (max(x) - min(x))))
}
calificacion <- function(x) {
return (100-(((x - min(x))*(100) )/ (max(x) - min(x))))
}
PromIndica$NORM <- normalize(PromIndica$PROM)
PromIndica$AVERAGE <- calificacion(PromIndica$PROM)
# Tabla Calificación -----------------------------------------------------
calif <- PromIndica %>%
dplyr::select(`ENTIDAD_FEDERATIVA`,
`AVERAGE`
) %>%
arrange(desc(AVERAGE))
colnames(calif)[colnames(calif)=="ENTIDAD_FEDERATIVA"] <- "ESTADO"
```
```{r}
#Tabla que muestra el número de pruebas que se hacen por día en los estados
formattable(calif, #llamo datos
align =c("l","c"), #Para alinear los datos de la tabla cada "" es una columna
list(`ESTADO` = formatter( #datos específicos
"span", style = ~ formattable::style(color = "grey",font.weight = "bold")),
`AVERAGE` = color_tile("transparent", "orange")# me crea una barra roja con proporción a los datos
)
)
```
Comparativa entre países (Contagios)
=========================================
```{r}
#Carga de datos que se necesitan para generar los datos de este sección
nuevos_casos_mundiales <- read_csv("https://raw.github.com/owid/covid-19-data/master/public/data/jhu/full_data.csv")
casos_por_millon <- read_csv("https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/jhu/new_cases_per_million.csv")
# creación de variables que se necesitan para esta sección
#vector para la selección de paises con población similar
poblacion_similiar <- c("Mexico",
"Japan",
"Russia",
"Bangladesh",
"Philippines")
#Paises de LATAM
latam <- c("Mexico", "Argentina",
"Colombia", "Chile",
"Brazil", "Bolivia",
"Costa Rica", "Ecuador",
"Guatemala", "Panama",
"Paraguay", "Peru",
"Puerto Rico", "Dominican Republic")
#Para la grafica GraphLatam
Comparativa_casos_latam <- casos_por_millon %>%
dplyr::select(date, matches(latam)) %>%
pivot_longer(
cols = 'Mexico':'Dominican Republic',
names_to = "Paises",
values_to = "Casos_por_millon"
) %>%
filter( Paises != "Ecuador")
Comparativa_casos_latam_tsbl<- Comparativa_casos_latam %>%
as_tsibble(
index = date,
key = Paises
)
```
Column
------------------------------------
### Escenario mundial (población similar)
```{r}
Comparativa_nuevos_casos <- nuevos_casos_mundiales %>%
ggplot(aes(x = date, y = new_cases, group = location)) +
geom_line(color = "grey") +
geom_line(data = nuevos_casos_mundiales %>% filter(location %in% poblacion_similiar),
aes(color = location), size = 1) +
scale_y_log10()
Comparativa_nuevos_casos
```
Column
------------------------------------
### Escenario LATAM
```{r}
GraphLatam <- Comparativa_casos_latam_tsbl %>%
filter(Paises != "Ecuador") %>% #Se elimina ecuador de la lista de paises por datos críticos negativos
as_tsibble(
index = date )%>%
ggplot() +
geom_line(mapping = aes(x = date, y = Casos_por_millon, color = Paises)) +
facet_wrap(~ Paises, scales = "free_y") +
theme(legend.position = "none")
GraphLatam
```
Vacunación en LATAM
=========================================
```{r}
#Datos de manejo y de carga para generar las visualizaciones en esta seccion
#carga de datos
#Se importan los datos como un tibble
Vacunastotales <- readr::read_csv("https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/vaccinations/vaccinations.csv")
#wrangle
#Se quiere trabajar con series de tiempo, entonces convertimos
# a tsibble un objeto que tiene orientación a este tiempo de
#procesamiento
Vacunastotales_tsibble <- Vacunastotales %>%
dplyr::mutate(Daily = as.Date(date)) %>%
dplyr::select(-date) %>%
tsibble::as_tsibble(key = location,
index = Daily)
#se hace una variable con los nombres de los paises de
#LATAM para asi poder llamar la variable a buscar en
#la base de datos si se requiere, esto esta pensado
#en que la instrucción podría hacerse varias veces
#entonces en teoría debería simplificar el código
latam <- c("Mexico", "Argentina",
"Colombia", "Chile",
"Brazil", "Bolivia",
"Costa Rica", "Ecuador",
"Guatemala", "Panama",
"Paraguay", "Peru",
"Puerto Rico", "Dominican Republic")
#Se encontro que era particularmente complicado mostrar
#todos los datos en una sola gráfica, por lo tanto,
#graficar por secciones y pegar con patchwork es una
#opción viable, por lo que la variable length(latam) = 14
#entonces dividimos en 2 grupos para tener símetria.
latam1 <- latam[1:7]
latam2 <- latam[8:14]
#latam == latam1 + latam2
#hacemos otro data frame que solo sea para los de
#LATAM y asi trabajamos con un tsibble más pequeña
Vacunas_latam_tsibble <- Vacunastotales_tsibble %>%
dplyr::select( Daily, location, total_vaccinations,
total_vaccinations_per_hundred,
daily_vaccinations_per_million) %>%
dplyr::filter(location %in% latam)
#Tratando los valores faltantes y los que estan fuera de rango
#VLT = contracción para Vacunas_latam_tsibble
VLT_miss <- Vacunas_latam_tsibble %>%
#filter(location %in% latam1) %>%
#anti_join(outliers) %>%
tsibble::fill_gaps() #aqui se remplazan por valores faltantes
#fill(direction = "down")
#A continuacion hacemos un modelo ARIMA que se ajuste
#a los datos que cotienen "valores faltantes"
VLT_fill <- VLT_miss %>%
fabletools::model(ARIMA(total_vaccinations_per_hundred)) %>%
fabletools::interpolate(VLT_miss)
```
Row
------------------------------------
### Escenario general
```{r}
#Gráfica que representa el escenario general para los paises
#de latam en el tiempo vacunados por cada 100
EscenarioLatam <- ggplot(data = Vacunas_latam_tsibble) +
geom_line(mapping = aes(x = Daily, y = total_vaccinations_per_hundred, color = location)) +
labs(x = 'meses',
y = 'Vacunas aplicadas por cada 100')
plotly::ggplotly(EscenarioLatam)
#Notas de el gráifco EscenarioLatam
#muestra una tendencia creciente
#con temporalidad variable
#No hay evidencia de comportmaiento ciclico
# EscenarioLatam <- ggplot(data = Vacunas_latam_tsibble) +
# geom_line(mapping = aes(x = Daily, y = total_vaccinations_per_hundred, color = location)) +
# labs(title = 'Escenario general de vacunación en LATAM ',
# x = 'meses',
# y = 'Vacunas aplicadas por cada 100')
#
# #Gráfica que representa el escenario general para los paises
# #de latam en el tiempo vacunados por cada 100 (rellenado)
#
# EscenarioLatam_fill <- ggplot(data = VLT_fill) +
# geom_line(mapping = aes(x = Daily, y = total_vaccinations_per_hundred, color = location)) +
# labs(title = 'Escenario general de vacunación en LATAM (sin valores faltantes)',
# x = 'meses',
# y = 'Vacunas aplicadas por cada 100')
#
# EscenarioLatam_Comparacion = EscenarioLatam + EscenarioLatam_fill
#
# EscenarioLatam_Comparacion
```
### Estacionalidad (Mensual)
```{r}
# #Visualización por periocidad -------------------------------------------
#Utilizando la función gg_season para hacer graficas
#de la vacunación (2 gráficas por pais correspondiente a los
# 2 años de los que se tienen datos) por mes.
Vacunas_latam_tsibble %>%
filter(location %in% latam1) %>%
gg_season(total_vaccinations_per_hundred, labels = "both") +
labs(y = "Vacunas aplicadas por cada 100",
x = "Meses",
title = "Vacunación por meses en los diferentes paises de LATAM") +
expand_limits(x = ymd(c("2021-02","2021-04"))) -> g1
#se repite el codigo para hacer lo mismo y luego juntarlos
#con el apoyo de patch work
Vacunas_latam_tsibble %>%
filter(location %in% latam2) %>%
gg_season(total_vaccinations_per_hundred, labels = "both") +
labs(y = "Vacunas aplicadas por cada 100",
x = "Meses",
title = "Vacunación por meses en los diferentes paises de LATAM") +
expand_limits(x = ymd(c("2021-02","2021-04"))) -> g2
#No se estiliza que la asignación vaya hasta el final
#pues transgrede con el estilo del código, pero se recomienda
#en el libro de forescasting para darle "fluidez" a la lectura
#del código
#Se encuentra interesante que en marzo la mayoría de los paises
#tienen una linea constante
#Méxio y chile empezaron la vacunación en las últimas semanas
#de diciembre
# Visualización: Integración de los gráficos con PATCHWORK -----------------------------
#Establecemos un layout, que es basicamente un # para los espacios en blanco, y letras
#para los lugares que deseamos que ocupe la letra
layout <- '
AAAABBBB
AAAABBBB
AAAABBBB
'
#cambiamos el lugar de las letras en el layout por nuestrras gráficas
wrap_plots(A = g1,
B = g2,
design = layout)
```
### Estacionalidad (semanal por mes)
```{r}
#Aquí vemos las gráficas anteriores más a detalle, pues podemos
#ver en que semanas de cada mes hay crecimiento
Vacunas_latam_tsibble %>%
filter(location %in% latam1) %>%
gg_season(total_vaccinations_per_hundred, period = "month") +
labs(y = "Vacunas aplicadas por cada 100",
x = "Estacionalidad semanal",
title = "Vacunación por semanana cada mes en los paises de LATAM") +
expand_limits(x = ymd(c("2021-02","2021-04"))) -> g3
#repetimos el código para la sección 2
Vacunas_latam_tsibble %>%
filter(location %in% latam2) %>%
gg_season(total_vaccinations_per_hundred, period = "month") +
labs(y = "Vacunas aplicadas por cada 100",
x = "Estacionalidad semanal",
title = "Vacunación por semanana cada mes en los paises de LATAM") +
expand_limits(x = ymd(c("2021-02","2021-04"))) -> g4
# Visualización: Integración de los gráficos con PATCHWORK -----------------------------
#Establecemos un layout, que es basicamente un # para los espacios en blanco, y letras
#para los lugares que deseamos que ocupe la letra
layout <- '
AAAABBBB
AAAABBBB
AAAABBBB
'
#cambiamos el lugar de las letras en el layout por nuestrras gráficas
wrap_plots(A = g3,
B = g4,
design = layout)
```
Vacunación en LATAM (Pronósticos)
=========================================
Row
------------------------------------
### TSLM
```{r}
# Modelo TSLM -------------------------------------------------------------
#https://www.rdocumentation.org/packages/forecast/versions/8.14/topics/tslm
#Descripción
#Fit a linear model with time series components
#tslm is used to fit linear models to time series including trend and seasonality components.
# Definición del modelo
#TSLM(total_vaccinations_per_hundred ~ trend())
# Entrenamiento del modelo (Estimación)
fit_TSLM <- Vacunas_latam_tsibble %>%
fabletools::model(Modelo_tendencia =
TSLM(total_vaccinations_per_hundred ~ trend()))
#Para datos rellenados
fit_TSLM_fill <- VLT_fill %>%
fabletools::model(Modelo_tendencia =
TSLM(total_vaccinations_per_hundred ~ trend()))
# Revisar el desempeño del modelo (evaluación)
# Producir pronósticos
#Se genera la tabla de pronósticos, el cual va ser
#una tabla de tipo fable (objeto) es decir
#forecasting table
fcst_TSLM <- fit_TSLM %>% forecast(h = 15) #se hace para los siguientes 3 meses
#pues los datos que se tienen hasta el momento
# son de 4 - 5 meses
#tabla de pronósticos, datos rellenados
fcst_TSLM_fill <- fit_TSLM_fill %>% forecast(h = 15)
# # Visualización de la forecasting table (OLD)
#
# #para grupo 1 latama
#
# fcst_TSLM %>%
# dplyr::filter(location %in% latam1) %>%
# autoplot(Vacunas_latam_tsibble) +
# ggtitle('Vacunas en LATAM') +
# ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_g1
#
# #para grupo 1 latam (rellenado)
#
# fcst_TSLM_fill %>%
# dplyr::filter(location %in% latam1) %>%
# autoplot(VLT_fill) +
# ggtitle('Vacunas en LATAM') +
# ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_fill_g1
#
# #para grupo 2 latam
#
# fcst_TSLM %>%
# dplyr::filter(location %in% latam2) %>%
# autoplot(Vacunas_latam_tsibble) +
# ggtitle('Vacunas en LATAM') +
# ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_g2
#
# #para grupo 2 latam (rellenado)
#
# fcst_TSLM_fill %>%
# dplyr::filter(location %in% latam2) %>%
# autoplot(VLT_fill) +
# ggtitle('Vacunas en LATAM') +
# ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_fill_g2
#visualización forescatsing table (new)
#latam sin rellenar
fcst_TSLM %>%
autoplot(Vacunas_latam_tsibble) +
facet_wrap(~location, ncol = 3, scales = 'free_y') +
ggtitle('Vacunas en LATAM') +
ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_g1
#latam rellenado
fcst_TSLM_fill %>%
autoplot(VLT_fill) +
facet_wrap(~location, ncol = 3, scales = 'free_y') +
ggtitle('Vacunas en LATAM') +
ylab('Vacunas aplicadas por cada 100') -> fcst_TSLM_fill_g1
#integración de las visualizaciones
fcst_TSLM_g3 = fcst_TSLM_g1 + fcst_TSLM_fill_g1
fcst_TSLM_g3
```
### ETS
```{r}
# Modelo ETS (suavización exponencial con tendencia) ----------------------------
#https://www.rdocumentation.org/packages/forecast/versions/8.14/topics/ets
#ETS = Exponential smoothing state space model
#Description
# Returns ETS model applied to "y"
#Parámetros estimados
#Estimamos alfa (entre 0 y 1, la tasa a la que disminuye "el peso" de los datos en el modelo, tambien conocida como el parametro de suavizacion)
#L0 o Lt (nivel, o valor suavizado)
#Beta (entre 0 y 1, es el coefficiente que representa la pendiente de la "tendencia" )
# 'A' es para 'aditivo' , 'M' para multiplicativo y 'N' para ninguno
# Como nuestros datos tienen una tendencia marcada, seleccionmos que tanto
#el error como la tendencia sean "aditivos"
fit_ETS_trend <- VLT_fill %>%
model(ETS(total_vaccinations_per_hundred ~ error('A') + trend('A') + season('N')))
#Generamos el pronóstico para 5 pasos después
fcst_ETS_trend <- fit_ETS_trend %>%
forecast(h = 15) %>%
autoplot(VLT_fill) +
facet_wrap(~location, ncol = 3, scales = 'free_y') +
labs(title = 'Pronóstico (modelo ETS)',
x = 'meses',
y = 'Vacunas aplicadas por cada 100') -> fcst_ETS_trend_g1
#El método de Holt es el que nos permite hacer suavizacion
#exponencial para datos con tendencia
#Holt tiene un problema, que la tendencia solo se establece
#como creciente o decreciente. Por lo que se desarrollo
#una funcion que hace este metodo pero amortiguado
# phi es el factor de "amortiguamiento", donde phi
# con un valor igual a 1, es identico al metodo de Holt sin
# amortiguamiento
#Ad -> aditive damped
fit_ETS_trendDamped <- VLT_fill %>%
model(ETS(total_vaccinations_per_hundred ~ error('A') + trend('Ad') + season('N')))
fcst_ETS_trendDamped <- fit_ETS_trendDamped %>%
forecast(h = 15) %>%
autoplot(VLT_fill) +
facet_wrap(~location, ncol = 3, scales = 'free_y') +
labs(title = 'Pronóstico (ETS amortiguado)',
x = 'meses',
y = 'Vacunas aplicadas por cada 100') -> fcst_ETS_trendDamped_g1
fcst_ETS_comparacion = fcst_ETS_trend_g1 + fcst_ETS_trendDamped_g1
fcst_ETS_comparacion
```